home *** CD-ROM | disk | FTP | other *** search
/ Aminet 2 / Aminet AMIGA CDROM (1994)(Walnut Creek)[Feb 1994][W.O. 44790-1].iso / Aminet / util / misc / Fudgit233.lha / Source / src / code.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-12-14  |  38.9 KB  |  1,879 lines
  1. #include <stdio.h>
  2. #include <string.h>
  3. #ifndef NOSTDLIB_H
  4. #include <stdlib.h>
  5. #endif
  6. #ifndef NOUNISTD_H
  7. #include <unistd.h>
  8. #endif
  9. #include "symbol.h"
  10. #include "code.h"
  11. #include "math.tab.h"
  12. #include "fudgit.h"
  13. #include "head.h"
  14.  
  15. extern char Ft_Format[];
  16. extern char Ft_TFormat[];
  17. extern FILE *Ft_Outprint;
  18.  
  19. #undef DEBUG
  20.  
  21. #ifdef DEBUG
  22. #define CODE(a) fprintf(stderr, "Run: %s\n", a)
  23. #define PNUM(a) fprintf(stderr, "Run: %g\n ", (double)a)
  24. #else
  25. #define CODE(a)
  26. #define PNUM(a)
  27. #endif
  28.  
  29. typedef struct Frame {
  30.     Symbol  *sp;
  31.     Inst    *retpc;
  32.     Datum   *argn;
  33.     int     nargs;
  34. } Frame;
  35.  
  36. int Ft_Indef = 0;
  37. int Ft_Inproto = 0;
  38. int Ft_Inauto = 0;
  39. int Ft_Inbrace = 0;
  40. Inst *Ft_Progp;
  41. Inst *Ft_Progbase;
  42.  
  43. static int Index = ERRR;
  44. static Inst *prog;
  45. static Inst *pc;
  46. static int Returning = 0;
  47. static int Break = 0;
  48. static Datum *stack;
  49. static Datum *stackp;
  50. static Frame *frame;
  51. static Frame *frp;
  52.  
  53. static void cleanfrp(int num), ret(void);
  54. static double *getarg(void);
  55. static Inst *checkargs(Inst *start, Frame *frpp);
  56. static char *makename(Symbol *sp);
  57.  
  58. void Ft_cleanframe(void), Ft_matherror(char *s1, char *s2, int lino);
  59. Code Ft_vecexec(int size);
  60.  
  61. extern char *strcat (char *, const char *);
  62. extern void Ft_free_dvector (double *v, int nl, int nh);
  63.  
  64. void Ft_resetprog(void)
  65. {
  66.     Ft_Progbase = prog;
  67. }
  68.  
  69. void Ft_resetindex(void)
  70. {
  71.     Index = ERRR;
  72. }
  73.     
  74. void Ft_initstacks(void)
  75. {
  76.     stack = (Datum *)malloc((unsigned)((NSTACK+2) * sizeof(Datum)));
  77.     if (stack == (Datum *)NULL) {
  78.         fputs("Math error: Fatal error on stack allocation.\n", stderr);
  79.         exit(1);
  80.     }
  81.     prog = (Inst *)malloc((unsigned)((NPROG+2) * sizeof(Inst)));
  82.     if (prog == (Inst *)NULL) {
  83.         fputs("Math error: Fatal error on stack allocation.\n", stderr);
  84.         exit(1);
  85.     }
  86.     frame = (Frame *)malloc((unsigned)((NFRAME+2) * sizeof(Frame)));
  87.     if (frame == (Frame *)NULL) {
  88.         fputs("Math error: Fatal error on stack allocation.\n", stderr);
  89.         exit(1);
  90.     }
  91.     frame[0].argn = stack;
  92.     frame[0].nargs = 0;
  93.     frame[0].sp = 0;
  94.     frp = ++frame;
  95.     Ft_Progbase = prog;
  96. }
  97.  
  98. int Ft_funcprocnotdef(void)
  99. {
  100.     if (Ft_Progbase == prog)
  101.         return(1);
  102.     return(0);
  103. }
  104.  
  105. void Ft_initcode(void)
  106. {
  107.     CODE("initcode");
  108.     Ft_Progp = Ft_Progbase;
  109.     Ft_cleanframe();
  110.     stackp = stack;
  111.     Returning = 0;
  112.     Break = 0;
  113. }
  114.  
  115. #ifndef MACROPOP
  116. Code Ft_push(Datum d)
  117. {
  118.     CODE("push");
  119.     if (stackp >= &stack[NSTACK]) {
  120.         Ft_matherror("Stack overflow.", NULL, 0);
  121.     }
  122.     *stackp = d;
  123.     stackp++;
  124. }
  125. #else
  126. #define Ft_push(a)    (*stackp++ = a)
  127. #endif
  128.  
  129. /* solving the problem for returning function on execute */
  130. Code Ft_nullpop(void)
  131. {
  132.     CODE("nullpop");
  133.     if (stackp <= stack)  {
  134.         Ft_matherror("Stack underflow.", NULL, 0);
  135.     }
  136.     stackp--;
  137. }
  138.  
  139. #ifndef MACROPOP
  140. Datum Ft_pop(void)
  141. {
  142.     CODE("pop");
  143.     if (stackp <= stack)  {
  144.         Ft_matherror("Stack underflow.", NULL, 0);
  145.     }
  146.     stackp--;
  147.     return(*stackp);
  148. }
  149. #else
  150. #define Ft_pop()    (*(--stackp))
  151. #endif
  152.  
  153. Inst *Ft_code(Inst f)
  154. {
  155.     Inst *oProgp = Ft_Progp;
  156.  
  157.     if (Ft_Progp >= &prog[NPROG]) {
  158.         Ft_matherror("Instruction code overflow.", NULL, 0);
  159.     }
  160.     *Ft_Progp = f;
  161.     Ft_Progp++;
  162.     return(oProgp);
  163. }
  164.  
  165. Inst *Ft_dblcode(double d)
  166. {
  167.     Inst *oProgp = Ft_Progp;
  168. #ifndef DALIGN
  169.     double *dp = (double *)Ft_Progp;
  170. #endif
  171.     if (Ft_Progp >= &prog[NPROG]) {
  172.         Ft_matherror("Instruction code overflow.", NULL, 0);
  173.     }
  174. #ifndef DALIGN
  175.     *dp = d;
  176. #else
  177.     bcopy((void *)&d, (void *)Ft_Progp, sizeof(double));
  178. #endif
  179.     Ft_Progp += (sizeof(double)/sizeof(Inst *));
  180.     return(oProgp);
  181. }
  182.  
  183. Code Ft_parloop(void)
  184. {
  185.     extern double *Ft_Param;
  186.  
  187.     Ft_vecexec((int)(*Ft_Param));
  188. }
  189.  
  190. Code Ft_vecloop(void)
  191. {
  192.     extern double *Ft_Data;
  193.  
  194.     Ft_vecexec((int)(*Ft_Data));
  195. }
  196.  
  197. /* called by loops */
  198. Code Ft_vecexec(int size)
  199. {
  200.     register Inst *pp;
  201.     Inst *basepc;
  202.     extern int Index;
  203.  
  204.     CODE("vexecute at");
  205.     PNUM((int)(pc-prog));
  206.     if (size == 0) {
  207.         Ft_matherror("Null size vector!", NULL, 0);
  208.     }
  209.     basepc = pc;
  210.  
  211.     /* !Returning and !Break do not have to be checked for */
  212.     /* since there is no statement in vexec */
  213.     for (Index = 1;Index <= size; Index++) {
  214.         pc = basepc;
  215.         while (*pc) {
  216.             pp = pc++;
  217.             (void) (*(*pp))();
  218.         }
  219.     }
  220.     /* Park Index variable */
  221.     Index = ERRR;
  222.     /* place pc after loop STOP */
  223.     pc++;
  224. }
  225.  
  226. void Ft_execute(Inst *p)
  227. {
  228.     register Inst *pp;
  229.  
  230.     CODE("execute at");
  231.     PNUM((int)(p-prog));
  232.     for (pc = p; *pc != STOP && !Returning && !Break; ) {
  233.         pp = pc++;
  234.         (void) (*(*pp))();
  235.     }
  236. }
  237.  
  238. Code Ft_varpush(void)
  239. {
  240.     Datum d;
  241.  
  242.     CODE("varpush");
  243.     d.sym = (Symbol *)(*pc);
  244.     pc++;
  245.     CODE(d.sym->name);
  246.     Ft_push(d);
  247. }
  248.  
  249. Code Ft_strpush(void)
  250. {
  251.     Datum d;
  252.  
  253.     CODE("strpush");
  254.     d.str = ((Symbol *)*pc)->u.str;
  255.     pc++;
  256.     CODE(d.str);
  257.     Ft_push(d);
  258. }
  259.  
  260. Code Ft_constpush(void)
  261. {
  262.     Datum d;
  263. #ifndef DALIGN
  264.     double *dp = (double *)pc;
  265.  
  266.     CODE("constpush");
  267.     d.val = *dp;
  268. #else
  269.  
  270.     CODE("constpush");
  271.     bcopy((void *)pc, (void *)&d.val, sizeof(double));
  272. #endif
  273.     pc += (sizeof(double)/sizeof(Inst *));
  274.     PNUM(d.val);
  275.     PNUM(d.val);
  276.     Ft_push(d);
  277. }
  278.  
  279. Code Ft_negate(void)
  280. {
  281.     Datum d;
  282.  
  283.     CODE("negate");
  284.     d  = Ft_pop();
  285.     d.val = -d.val;
  286.     Ft_push(d);
  287. }
  288.  
  289. Code Ft_strsub(void)
  290. {
  291.     static char diff[TOKENSIZE+4];
  292.     Datum d1, d2;
  293.     register char *cp1, *cp2;
  294.  
  295.     CODE("strsub");
  296.     d2  = Ft_pop();
  297.     d1  = Ft_pop();
  298.     strcpy(diff, d1.str);
  299.     d1.str = cp1 = diff;
  300.     cp2 = d2.str;
  301.     while (*cp1)
  302.         cp1++;
  303.     while (*cp2)
  304.         cp2++;
  305.     while (*cp1 == *cp2 || *cp2 == '?') {
  306.         *cp1 = '\0';
  307.         cp1--; cp2--;
  308.         if (cp1 < diff || cp2 < d2.str)
  309.             break;
  310.     }
  311.     Ft_push(d1);
  312. }
  313.  
  314. Code Ft_stradd(void)
  315. {
  316.     static char total[TOKENSIZE+4];
  317.     Datum d1, d2;
  318.  
  319.     CODE("stradd");
  320.     d2  = Ft_pop();
  321.     d1  = Ft_pop();
  322.     if (strlen(d1.str) + strlen(d2.str) > TOKENSIZE) {
  323.         Ft_matherror("String addition: Result too long.", NULL, 0);
  324.     }
  325.     if (d2.str != total) {
  326.         strcpy(total, d1.str);
  327.         strcat(total, d2.str);
  328.     }
  329.     else {
  330.         char tmp[TOKENSIZE+4];
  331.  
  332.         strcpy(tmp, d2.str);
  333.         strcpy(total, d1.str);
  334.         strcat(total, tmp);
  335.     }
  336.     d1.str = total;
  337.     Ft_push(d1);
  338. }
  339.  
  340. Code Ft_add(void)
  341. {
  342.     Datum d1, d2;
  343.  
  344.     CODE("add");
  345.     d2  = Ft_pop();
  346.     d1  = Ft_pop();
  347.     d1.val += d2.val;
  348.     Ft_push(d1);
  349. }
  350.  
  351. Code Ft_sub(void)
  352. {
  353.     Datum d1, d2;
  354.  
  355.     CODE("sub");
  356.     d2  = Ft_pop();
  357.     d1  = Ft_pop();
  358.     d1.val -= d2.val;
  359.     Ft_push(d1);
  360. }
  361.  
  362. Code Ft_mul(void)
  363. {
  364.     Datum d1, d2;
  365.  
  366.     CODE("mul");
  367.     d2  = Ft_pop();
  368.     d1  = Ft_pop();
  369.     d1.val *= d2.val;
  370.     Ft_push(d1);
  371. }
  372.  
  373. Code Ft_div(void)
  374. {
  375.     Datum d1, d2;
  376.     extern int Ft_Check;
  377.  
  378.     CODE("div");
  379.     d2  = Ft_pop();
  380.     if (d2.val == 0.0 && Ft_Check & INF_CHK) {
  381.         Ft_matherror("Division by zero.", NULL, 0);
  382.     }
  383.     d1 = Ft_pop();
  384.     d1.val /= d2.val;
  385.     Ft_push(d1);
  386. }
  387.  
  388. Code Ft_modulo(void)
  389. {
  390.     Datum d1, d2;
  391.     int tmp1, tmp2;
  392.     extern int Ft_Check;
  393.  
  394.     CODE("modulo");
  395.     d2  = Ft_pop();
  396.     d1  = Ft_pop();
  397.     if (d2.val == 0.0 && Ft_Check & INF_CHK) {
  398.         Ft_matherror("Modulo division by zero.", NULL, 0);
  399.     }
  400.     tmp1 = d1.val;
  401.     tmp2 = d2.val;
  402.     d1.val = tmp1%tmp2;
  403.     Ft_push(d1);
  404. }
  405.  
  406. Code Ft_extcall(void)
  407. {
  408.     Datum d;
  409.     Symbol *sym;
  410.     double dblvec[MATHMAXARG];
  411.     void *ptrvec[MATHMAXARG];
  412.     int ino, argno, type;
  413.     char *tvec;
  414.  
  415.     CODE("pointer");
  416.     sym = (Symbol *) *pc;
  417.     pc++;
  418.     CODE("number");
  419.     argno = (int) *pc;
  420.     pc++;
  421.     if (argno >= MATHMAXARG)
  422.         Ft_matherror("%s: Too many arguments (%d).", sym->name, argno);
  423.     tvec = sym->size.vals;  /* types stored there */
  424.     for (ino=argno;ino > 0;ino--) {
  425.         d = Ft_pop();
  426.         type = (int) d.val;
  427.         d = Ft_pop();
  428.         if (!tvec[0])
  429.             Ft_matherror("%s: Too many arguments (%d required).",
  430.             sym->name, (argno-ino));
  431.         switch(*tvec) {
  432.         case PROTO_VAL:
  433.             if (type != NUMBER)
  434.                 Ft_matherror("%s: Argument %d not an expr.",
  435.                 sym->name, ino);
  436.             dblvec[ino-1] = d.val;
  437.             ptrvec[ino-1] = (void *) (dblvec+ino-1);
  438.             break;
  439.         case PROTO_VEC:
  440.             if (type != VEC)
  441.                 Ft_matherror("%s: Argument %d not a VEC.", sym->name, ino);
  442.             ptrvec[ino-1] = (void *) (d.sym->u.vec + 1);
  443.             break;
  444.         case PROTO_PAR:
  445.             if (type != PARAM)
  446.                 Ft_matherror("%s: Argument %d not a PARAM.", sym->name, ino);
  447.             ptrvec[ino-1] = (void *)(d.sym->u.vec + 1);
  448.             break;
  449.         case PROTO_STR:
  450.             if (type != STRVAR)
  451.                 Ft_matherror("%s: Argument %d not a String.",
  452.                 sym->name, ino);
  453.             ptrvec[ino-1] = (void *)d.sym->u.str;
  454.             break;
  455.         default:
  456.             Ft_matherror("%s: Unknown type in definition.", sym->name, 0);
  457.         }
  458.         tvec++;
  459.     }    
  460.     if (tvec[0])
  461.         Ft_matherror("%s: Not enough arguments (%d).", sym->name, argno);
  462.     if (sym->type == EFUNCSYM) {
  463.         d.val = ( *(double (*)(double *, ...)) sym->u.ptr) (
  464.         ptrvec[0],  ptrvec[1],  ptrvec[2],  ptrvec[3],  ptrvec[4],
  465.         ptrvec[5],  ptrvec[6],  ptrvec[7],  ptrvec[8],  ptrvec[9],
  466.         ptrvec[10], ptrvec[11], ptrvec[12], ptrvec[13], ptrvec[14],
  467.         ptrvec[15], ptrvec[16], ptrvec[17], ptrvec[18], ptrvec[19],
  468.         ptrvec[20], ptrvec[21], ptrvec[22], ptrvec[23], ptrvec[24],
  469.         ptrvec[25], ptrvec[26], ptrvec[27], ptrvec[28], ptrvec[29],
  470.         ptrvec[30], ptrvec[31], ptrvec[32], ptrvec[33], ptrvec[34]);
  471.         Ft_push(d);
  472.     } else {
  473.         (void) ( *(double (*)(double *, ...))sym->u.ptr) (
  474.         ptrvec[0],  ptrvec[1],  ptrvec[2],  ptrvec[3],  ptrvec[4],
  475.         ptrvec[5],  ptrvec[6],  ptrvec[7],  ptrvec[8],  ptrvec[9],
  476.         ptrvec[10], ptrvec[11], ptrvec[12], ptrvec[13], ptrvec[14],
  477.         ptrvec[15], ptrvec[16], ptrvec[17], ptrvec[18], ptrvec[19],
  478.         ptrvec[20], ptrvec[21], ptrvec[22], ptrvec[23], ptrvec[24],
  479.         ptrvec[25], ptrvec[26], ptrvec[27], ptrvec[28], ptrvec[29],
  480.         ptrvec[30], ptrvec[31], ptrvec[32], ptrvec[33], ptrvec[34]);
  481.     }
  482. }
  483.  
  484. Code Ft_bltin0str(void)
  485. {
  486.     Datum d;
  487.  
  488.     CODE("builtin0str");
  489.     CODE("pointer");
  490.     d.str = (*(char *(*)(void))(*pc))();
  491.     pc++;
  492.     Ft_push(d);
  493. }
  494.  
  495. Code Ft_bltin0(void)
  496. {
  497.     Datum d;
  498.  
  499.     CODE("builtin0");
  500.     CODE("pointer");
  501.     d.val = (*(double (*)(void))(*pc))();
  502.     pc++;
  503.     Ft_push(d);
  504. }
  505.  
  506. Code Ft_bltin1(void)
  507. {
  508.     Datum d;
  509.  
  510.     CODE("builtin1");
  511.     d = Ft_pop();
  512.     CODE("pointer");
  513.     d.val = (*(double (*)(double))(*pc))(d.val);
  514.     pc++;
  515.     Ft_push(d);
  516. }
  517.  
  518. Code Ft_bltin1vec(void)
  519. {
  520.     Datum d;
  521.  
  522.     CODE("builtin1vec");
  523.     d = Ft_pop();
  524.     CODE("pointer");
  525.     d.val = (*(double (*)(double *))(*pc))(d.sym->u.vec);
  526.     pc++;
  527.     Ft_push(d);
  528. }
  529.  
  530. Code Ft_bltin2(void)
  531. {
  532.     Datum d1, d2;
  533.  
  534.     CODE("bltin2");
  535.     d2 = Ft_pop();
  536.     d1 = Ft_pop();
  537.     CODE("pointer");
  538.     d1.val = (*(double (*)(double, double))(*pc))(d1.val, d2.val);
  539.     pc++;
  540.     Ft_push(d1);
  541. }
  542.  
  543. Code Ft_bltin1str(void)
  544. {
  545.     Datum d;
  546.  
  547.     CODE("bltin1str");
  548.     d = Ft_pop();
  549.     CODE("pointer");
  550.     d.str = (*(char *(*)(char *))(*pc))(d.str);
  551.     pc++;
  552.     Ft_push(d);
  553. }
  554.  
  555. Code Ft_bltin2str(void)
  556. {
  557.     Datum d1, d2;
  558.  
  559.     CODE("bltin2str");
  560.     d2 = Ft_pop();
  561.     d1 = Ft_pop();
  562.     CODE("pointer");
  563.     d1.str = (*(char *(*)(char *, char *))(*pc))(d1.str, d2.str);
  564.     pc++;
  565.     Ft_push(d1);
  566. }
  567.  
  568. Code Ft_strbltin2(void)
  569. {
  570.     Datum d1, d2;
  571.  
  572.     CODE("strbltin2");
  573.     d2 = Ft_pop();
  574.     d1 = Ft_pop();
  575.     CODE("pointer");
  576.     d1.val = (*(double (*)(char *, char *))(*pc))(d1.str, d2.str);
  577.     pc++;
  578.     Ft_push(d1);
  579. }
  580.  
  581. Code Ft_power(void)
  582. {
  583.     Datum d1, d2;
  584.     extern double Ft_Pow(double x, double y);
  585.  
  586.     CODE("power");
  587.     d2 = Ft_pop();
  588.     d1 = Ft_pop();
  589.     d1.val = Ft_Pow(d1.val, d2.val);
  590.     Ft_push(d1);
  591. }
  592.  
  593. Code Ft_eeval(void)
  594. {
  595.     Datum d1, d2;
  596.     register int index;
  597.  
  598.     CODE("eeval");
  599.     d1 = Ft_pop();
  600.     /*********************
  601.     if (d1.sym->type != VEC && d1.sym->type != PARAM) {
  602.         Ft_matherror("%s: Not a vector or parameter.", d1.sym->name, 0);
  603.     }
  604.     **********************/
  605.     d2 = Ft_pop();
  606.     index = (int) d2.val;
  607.     if (index < 1 || index > d1.sym->size.val) {
  608.         Ft_matherror("%s: Index %d out of range.", d1.sym->name, index);
  609.     }
  610.     d2.val = d1.sym->u.vec[index];
  611.     Ft_push(d2);
  612. }
  613.  
  614. Code Ft_postieval(void)
  615. {
  616.     Datum d1, d2;
  617.  
  618.     CODE("postieval");
  619.     d1 = Ft_pop();
  620.     if (d1.sym->type == VAR || d1.sym->type == BLTINVAR) {
  621.         d2.val = d1.sym->u.val;
  622.         d1.sym->u.val += 1.0;
  623.         Ft_push(d2);
  624.         return;
  625.     }
  626.     if (d1.sym->type == UNDEFVAR) {
  627.         Ft_matherror("%s: Unassigned variable.", d1.sym->name, 0);
  628.     }
  629.     Ft_matherror("%s: Not a regular variable.", d1.sym->name, 0);
  630. }
  631.  
  632. Code Ft_postdeval(void)
  633. {
  634.     Datum d1, d2;
  635.  
  636.     CODE("postdeval");
  637.     d1 = Ft_pop();
  638.     if (d1.sym->type == VAR || d1.sym->type == BLTINVAR) {
  639.         d2.val = d1.sym->u.val;
  640.         d1.sym->u.val -= 1.0;
  641.         Ft_push(d2);
  642.         return;
  643.     }
  644.     if (d1.sym->type == UNDEFVAR) {
  645.         Ft_matherror("%s: Unassigned variable.", d1.sym->name, 0);
  646.     }
  647.     Ft_matherror("%s: Not a regular variable.", d1.sym->name, 0);
  648. }
  649.  
  650. Code Ft_preieval(void)
  651. {
  652.     Datum d;
  653.  
  654.     CODE("preieval");
  655.     d = Ft_pop();
  656.     if (d.sym->type == VAR || d.sym->type == BLTINVAR) {
  657.         d.sym->u.val += 1.0;
  658.         d.val = d.sym->u.val;
  659.         Ft_push(d);
  660.         return;
  661.     }
  662.     if (d.sym->type == UNDEFVAR) {
  663.         Ft_matherror("%s: Unassigned variable.", d.sym->name, 0);
  664.     }
  665.     Ft_matherror("%s: Not a regular variable.", d.sym->name, 0);
  666. }
  667.  
  668. Code Ft_predeval(void)
  669. {
  670.     Datum d;
  671.  
  672.     CODE("predeval");
  673.     d = Ft_pop();
  674.     if (d.sym->type == VAR || d.sym->type == BLTINVAR) {
  675.         d.sym->u.val -= 1.0;
  676.         d.val = d.sym->u.val;
  677.         Ft_push(d);
  678.         return;
  679.     }
  680.     if (d.sym->type == UNDEFVAR) {
  681.         Ft_matherror("%s: Unassigned variable.", d.sym->name, 0);
  682.     }
  683.     Ft_matherror("%s: Not a regular variable.", d.sym->name, 0);
  684. }
  685.  
  686. Code Ft_eval(void)
  687. {
  688.     extern int Index;
  689.     register int type;
  690.     Datum d;
  691.  
  692.     CODE("eval");
  693.     d = Ft_pop();
  694.     type = d.sym->type;
  695.     if (type == VEC || type == PARAM) {
  696.         if (Index == ERRR) {
  697.             Ft_matherror("%s: Illegal vector assignment.", d.sym->name, 0);
  698.         }
  699.         d.val = d.sym->u.vec[Index];
  700.         Ft_push(d);
  701.         return;
  702.     }
  703.     if (type >= VAR && type <= BLTINCONST) {
  704.         d.val = d.sym->u.val;
  705.         Ft_push(d);
  706.         return;
  707.     }
  708.     if (type == UNDEFVEC) {
  709.         Ft_matherror("%s: Unassigned vector.", d.sym->name, 0);
  710.     }
  711.     if (type == UNDEFVAR) {
  712.         Ft_matherror("%s: Unassigned variable.", d.sym->name, 0);
  713.     }
  714.     Ft_matherror("%s: Not a regular variable.", d.sym->name, 0);
  715. }
  716.  
  717. Code Ft_streval(void)
  718. {
  719.     Datum d;
  720.  
  721.     CODE("streval");
  722.     d = Ft_pop();
  723.     if (d.sym->type >= STRVAR && d.sym->type <= BLTINSTRCONST) {
  724.         d.str = d.sym->u.str;
  725.         Ft_push(d);
  726.         return;
  727.     }
  728.     if (d.sym->type == UNDEFSTRVAR) {
  729.         Ft_matherror("%s: Unassigned string variable.", d.sym->name, 0);
  730.     }
  731.     Ft_matherror("%s: Not a regular string variable.", d.sym->name, 0);
  732. }
  733.  
  734. Code Ft_eassign(void)
  735. {
  736.     Datum d1, d2, d3;
  737.     int index;
  738.  
  739.     CODE("eassign");
  740.     d1 = Ft_pop();
  741.     if (d1.sym->type != VEC && d1.sym->type != PARAM
  742.     && d1.sym->type != UNDEFVEC) {
  743.         Ft_matherror("%s: Illegal element assignment.", d1.sym->name, 0);
  744.     }
  745.     d2 = Ft_pop();
  746.     d3 = Ft_pop();
  747.     index = (int)d3.val;
  748.     if (index < 1 || index > d1.sym->size.val) {
  749.         Ft_matherror("%s: Index %d out of range.", d1.sym->name, index);
  750.     }
  751.     d1.sym->u.vec[index] = d2.val;
  752.     if (d1.sym->type == UNDEFVEC) {
  753.         d1.sym->type = VEC;
  754.     }
  755.     Ft_push(d2);
  756. }
  757.  
  758. Code Ft_assign(void)
  759. {
  760.     Datum d1, d2;
  761.  
  762.     CODE("assign");
  763.     d1 = Ft_pop();
  764.     d2 = Ft_pop();
  765.     if (d1.sym->type == VEC || d1.sym->type == PARAM
  766.     || d1.sym->type == UNDEFVEC) {
  767.         if (Index == ERRR) { /* assignment from vexecute() only */
  768.             Ft_matherror("%s: Illegal vector assignment.", d1.sym->name, 0);
  769.         }
  770.         d1.sym->u.vec[Index] = d2.val;
  771.         if (d1.sym->type == UNDEFVEC) {
  772.             d1.sym->type = VEC;
  773.         }
  774.     }
  775.     else if (d1.sym->type == VAR || d1.sym->type == BLTINVAR) {
  776.         d1.sym->u.val = d2.val;
  777.     }
  778.     else if (d1.sym->type == UNDEFVAR) {
  779.         d1.sym->u.val = d2.val;
  780.         d1.sym->type = VAR;
  781.     }
  782.     else {
  783.         Ft_matherror("%s: Assignment to non-variable.", d1.sym->name, 0);
  784.     }
  785.     Ft_push(d2);
  786. }
  787.  
  788. Code Ft_strassign(void)
  789. {
  790.     Datum d1, d2;
  791.  
  792.     CODE("strassign");
  793.     d1 = Ft_pop();
  794.     d2 = Ft_pop();
  795.     if (d1.sym->type != STRVAR && d1.sym->type != UNDEFSTRVAR &&
  796.     d1.sym->type != BLTINSTRVAR) {
  797.         Ft_matherror("%s: Assignment to non-string variable.", d1.sym->name, 0);
  798.     }
  799.     if (d1.sym->type != UNDEFSTRVAR) {
  800.         free(d1.sym->u.str);
  801.     }
  802.     else {
  803.         d1.sym->type = STRVAR;
  804.     }
  805.     if ((d1.sym->u.str = (char *)malloc(strlen(d2.str) + 1)) == (char *)NULL) {
  806.         Ft_matherror("Allocation error in string assignment.", NULL, 0);
  807.     }
  808.     strcpy(d1.sym->u.str, d2.str);
  809.     Ft_push(d2);
  810. }
  811.  
  812. Code Ft_le(void)
  813. {
  814.     Datum d1, d2;
  815.  
  816.     CODE("le");
  817.     d2 = Ft_pop();
  818.     d1 = Ft_pop();
  819.     d1.val = (double) (d1.val <= d2.val);
  820.     Ft_push(d1);
  821. }
  822.  
  823. Code Ft_lt(void)
  824. {
  825.     Datum d1, d2;
  826.  
  827.     CODE("lt");
  828.     d2 = Ft_pop();
  829.     d1 = Ft_pop();
  830.     d1.val = (double) (d1.val < d2.val);
  831.     Ft_push(d1);
  832. }
  833.  
  834.  
  835. Code Ft_ge(void)
  836. {
  837.     Datum d1, d2;
  838.  
  839.     CODE("ge");
  840.     d2 = Ft_pop();
  841.     d1 = Ft_pop();
  842.     d1.val = (double) (d1.val >= d2.val);
  843.     Ft_push(d1);
  844. }
  845.  
  846. Code Ft_gt(void)
  847. {
  848.     Datum d1, d2;
  849.  
  850.     CODE("gt");
  851.     d2 = Ft_pop();
  852.     d1 = Ft_pop();
  853.     d1.val = (double) (d1.val > d2.val);
  854.     Ft_push(d1);
  855. }
  856.  
  857. Code Ft_ne(void)
  858. {
  859.     Datum d1, d2;
  860.  
  861.     CODE("ne");
  862.     d2 = Ft_pop();
  863.     d1 = Ft_pop();
  864.     d1.val = (double) (d1.val != d2.val);
  865.     Ft_push(d1);
  866. }
  867.  
  868. Code Ft_eq(void)
  869. {
  870.     Datum d1, d2;
  871.  
  872.     CODE("eq");
  873.     d2 = Ft_pop();
  874.     d1 = Ft_pop();
  875.     d1.val = (double) (d1.val == d2.val);
  876.     Ft_push(d1);
  877. }
  878.  
  879. Code Ft_streq(void)
  880. {
  881.     Datum d1, d2;
  882.  
  883.     CODE("eq");
  884.     d2 = Ft_pop();
  885.     d1 = Ft_pop();
  886.     d1.val = (double) (strcmp(d1.str, d2.str) == 0);
  887.     Ft_push(d1);
  888. }
  889.  
  890. Code Ft_strne(void)
  891. {
  892.     Datum d1, d2;
  893.  
  894.     CODE("eq");
  895.     d2 = Ft_pop();
  896.     d1 = Ft_pop();
  897.     d1.val = (double) (strcmp(d1.str, d2.str) != 0);
  898.     Ft_push(d1);
  899. }
  900.  
  901. Code Ft_and(void)
  902. {
  903.     Datum d1, d2;
  904.  
  905.     CODE("and");
  906.     d2 = Ft_pop();
  907.     d1 = Ft_pop();
  908.     d1.val = (double) ((d1.val != 0.0) && (d2.val != 0.0));
  909.     Ft_push(d1);
  910. }
  911.  
  912. Code Ft_or(void)
  913. {
  914.     Datum d1, d2;
  915.  
  916.     CODE("or");
  917.     d2 = Ft_pop();
  918.     d1 = Ft_pop();
  919.     d1.val = (double) ((d1.val != 0.0) || (d2.val != 0.0));
  920.     Ft_push(d1);
  921. }
  922.  
  923. Code Ft_not(void)
  924. {
  925.     Datum d;
  926.  
  927.     CODE("not");
  928.     d = Ft_pop();
  929.     d.val = (double) (d.val == 0.0);
  930.     Ft_push(d);
  931. }
  932.  
  933. Code Ft_whilecode(void)
  934. {
  935.     Datum d;
  936.     Inst *savepc = pc;  /* pc is the next instruction */
  937.  
  938.     CODE("whilecode");
  939.     Break = 0;
  940.     Ft_execute(savepc+2);   /* the condition */
  941.     d = Ft_pop();
  942.     while (d.val) {
  943.           Ft_execute(*((Inst **)(savepc))); /* the body */
  944.           if (Break || Returning)
  945.             break;
  946.           Ft_execute(savepc + 2);
  947.           d = Ft_pop();
  948.     }
  949.     if (!Returning)
  950.         pc = *((Inst **)(savepc+1));
  951. }
  952.  
  953. Code Ft_forcode(void)
  954. {
  955.     Datum d;
  956.     Inst *savepc = pc;  /* pc is the next to for itself  */
  957.  
  958.     CODE("forcode");
  959.     Break = 0;
  960.     Ft_execute(savepc+4);  /* assignments */
  961.     Ft_execute(*((Inst **)savepc));   /* the condition */
  962.     d = Ft_pop();
  963.     while (d.val) {
  964.           Ft_execute(*((Inst **)(savepc+2))); /* the body-statement */
  965.           if (Break || Returning)
  966.             break;
  967.           Ft_execute(*(Inst **)(savepc+1));  /* the expression list */
  968.           Ft_execute(*(Inst **)savepc);  /* the conditional expression */
  969.           d = Ft_pop();
  970.     }
  971.     if (!Returning)
  972.         pc = *((Inst **)(savepc+3));
  973. }
  974.  
  975. Code Ft_ifcode(void)
  976. {
  977.     Datum d;
  978.     Inst *savepc = pc;
  979.  
  980.     CODE("ifcode");
  981.     Ft_execute(savepc+3);
  982.     d = Ft_pop();
  983.     if (d.val)
  984.          Ft_execute(*((Inst **) (savepc)));
  985.     else if (*((Inst **)(savepc+1)))
  986.          Ft_execute(*((Inst **) (savepc+1)));
  987.     if (!Returning)
  988.         pc = *((Inst**)(savepc+2));
  989. }
  990.  
  991. Code Ft_linprnl(void)
  992. {
  993.     CODE("linprnl");
  994.     fputc('\n', stdout);
  995.     fflush(stdout);
  996. }
  997.  
  998. Code Ft_linprexpr(void)
  999. {
  1000.     Datum d;
  1001.  
  1002.     CODE("linprexpr");
  1003.     d = Ft_pop();
  1004.     fprintf(stdout, Ft_Format, d.val);
  1005.     fputc('\t', stdout);
  1006.     fflush(stdout);
  1007. }
  1008.  
  1009. Code Ft_linprstr(void)
  1010. {
  1011.     Datum d;
  1012.  
  1013.     CODE("linprstr");
  1014.     d = Ft_pop();
  1015.     fputs(d.str, stdout);
  1016.     fflush(stdout);
  1017. }
  1018.  
  1019. Code Ft_prstr(void)
  1020. {
  1021.     Datum d;
  1022.  
  1023.     CODE("prstr");
  1024.     d = Ft_pop();
  1025.     fputs(d.str, Ft_Outprint);
  1026.     fflush(Ft_Outprint);
  1027. }
  1028.  
  1029. Code Ft_prexpr(void)
  1030. {
  1031.     Datum d;
  1032.  
  1033.     CODE("prexpr");
  1034.     d = Ft_pop();
  1035.     fprintf(Ft_Outprint, Ft_Format, d.val);
  1036.     fputc('\t', Ft_Outprint);
  1037.     fflush(Ft_Outprint);
  1038. }
  1039.  
  1040. Code Ft_addassign(void)
  1041. {
  1042.     Datum d1, d2;
  1043.  
  1044.     CODE("addassign");
  1045.     d1 = Ft_pop();
  1046.     d2 = Ft_pop();
  1047.     if (d1.sym->type == VEC || d1.sym->type == PARAM) {
  1048.         if (Index == ERRR) { /* assignment from vexecute() only */
  1049.             Ft_matherror("%s: Illegal vector assignment.", d1.sym->name, 0);
  1050.         }
  1051.         d2.val = (d1.sym->u.vec[Index] += d2.val);
  1052.         Ft_push(d2);
  1053.         return;
  1054.     }
  1055.     if (d1.sym->type == VAR || d1.sym->type == BLTINVAR) {
  1056.         d2.val = (d1.sym->u.val += d2.val);
  1057.         Ft_push(d2);
  1058.         return;
  1059.     }
  1060.     if (d1.sym->type == UNDEFVAR || d1.sym->type == UNDEFVEC) {
  1061.         Ft_matherror("%s: Unassigned variable.", d1.sym->name, 0);
  1062.     }
  1063.     Ft_matherror("%s: Assignment to non-variable.", d1.sym->name, 0);
  1064. }
  1065.  
  1066. Code Ft_mulassign(void)
  1067. {
  1068.     Datum d1, d2;
  1069.  
  1070.     CODE("mulassign");
  1071.     d1 = Ft_pop();
  1072.     d2 = Ft_pop();
  1073.     if (d1.sym->type == VEC || d1.sym->type == PARAM) {
  1074.         if (Index == ERRR) { /* assignment from vexecute() only */
  1075.             Ft_matherror("%s: Illegal vector assignment.", d1.sym->name, 0);
  1076.         }
  1077.         d2.val = (d1.sym->u.vec[Index] *= d2.val);
  1078.         Ft_push(d2);
  1079.         return;
  1080.     }
  1081.     if (d1.sym->type == VAR || d1.sym->type == BLTINVAR) {
  1082.         d2.val = (d1.sym->u.val *= d2.val);
  1083.         Ft_push(d2);
  1084.         return;
  1085.     }
  1086.     if (d1.sym->type == UNDEFVAR || d1.sym->type == UNDEFVEC) {
  1087.         Ft_matherror("%s: Unassigned variable.", d1.sym->name, 0);
  1088.     }
  1089.     Ft_matherror("%s: Assignment to non-variable.", d1.sym->name, 0);
  1090. }
  1091.  
  1092. Code Ft_divassign(void)
  1093. {
  1094.     Datum d1, d2;
  1095.     extern int Ft_Check;
  1096.  
  1097.     CODE("divassign");
  1098.     d1 = Ft_pop();
  1099.     d2 = Ft_pop();
  1100.     if (d1.sym->type == VEC || d1.sym->type == PARAM) {
  1101.         if (Index == ERRR) { /* assignment from vexecute() only */
  1102.             Ft_matherror("%s: Illegal vector assignment.", d1.sym->name, 0);
  1103.         }
  1104.         if (d2.val == 0.0 && Ft_Check & INF_CHK) {
  1105.             Ft_matherror("%s: Division by zero.", d1.sym->name, 0);
  1106.         }
  1107.         d2.val = (d1.sym->u.vec[Index] /= d2.val);
  1108.         Ft_push(d2);
  1109.         return;
  1110.     }
  1111.     if (d1.sym->type == VAR || d1.sym->type == BLTINVAR) {
  1112.         if (d2.val == 0.0 && Ft_Check & INF_CHK) {
  1113.             Ft_matherror("%s: Division by zero.", d1.sym->name, 0);
  1114.         }
  1115.         d2.val = (d1.sym->u.val /= d2.val);
  1116.         Ft_push(d2);
  1117.         return;
  1118.     }
  1119.     if (d1.sym->type == UNDEFVAR || d1.sym->type == UNDEFVEC) {
  1120.         Ft_matherror("%s: Unassigned variable.", d1.sym->name, 0);
  1121.     }
  1122.     Ft_matherror("%s: Assignment to non-variable.", d1.sym->name, 0);
  1123. }
  1124.  
  1125. Code Ft_subassign(void)
  1126. {
  1127.     Datum d1, d2;
  1128.  
  1129.     CODE("subassign");
  1130.     d1 = Ft_pop();
  1131.     d2 = Ft_pop();
  1132.     if (d1.sym->type == VEC || d1.sym->type == PARAM) {
  1133.         if (Index == ERRR) { /* assignment from vexecute() only */
  1134.             Ft_matherror("%s: Illegal vector assignment.", d1.sym->name, 0);
  1135.         }
  1136.         d2.val = (d1.sym->u.vec[Index] -= d2.val);
  1137.         Ft_push(d2);
  1138.         return;
  1139.     }
  1140.     if (d1.sym->type == VAR || d1.sym->type == BLTINVAR) {
  1141.         d2.val = (d1.sym->u.val -= d2.val);
  1142.         Ft_push(d2);
  1143.         return;
  1144.     }
  1145.     if (d1.sym->type == UNDEFVAR || d1.sym->type == UNDEFVEC) {
  1146.         Ft_matherror("%s: Unassigned variable.", d1.sym->name, 0);
  1147.     }
  1148.     Ft_matherror("%s: Assignment to non-variable.", d1.sym->name, 0);
  1149. }
  1150.  
  1151. Code Ft_eaddassign(void)
  1152. {
  1153.     Datum d1, d2, d3;
  1154.     int index;
  1155.  
  1156.     CODE("eaddassign");
  1157.     d1 = Ft_pop();
  1158.     if (d1.sym->type != VEC && d1.sym->type != PARAM) {
  1159.         if (d1.sym->type == UNDEFVAR || d1.sym->type == UNDEFVEC)
  1160.             Ft_matherror("%s: Unassigned vector.", d1.sym->name, 0);
  1161.         else
  1162.             Ft_matherror("%s: Illegal element assignment.", d1.sym->name, 0);
  1163.     }
  1164.     d2 = Ft_pop();
  1165.     d3 = Ft_pop();
  1166.     index = (int)d3.val;
  1167.     if (index < 1 || index > d1.sym->size.val) {
  1168.         Ft_matherror("%s: Index %d out of range.", d1.sym->name, index);
  1169.     }
  1170.     d2.val = (d1.sym->u.vec[index] += d2.val);
  1171.     Ft_push(d2);
  1172. }
  1173.  
  1174. Code Ft_emulassign(void)
  1175. {
  1176.     Datum d1, d2, d3;
  1177.     int index;
  1178.  
  1179.     CODE("emulassign");
  1180.     d1 = Ft_pop();
  1181.     if (d1.sym->type != VEC && d1.sym->type != PARAM) {
  1182.         if (d1.sym->type == UNDEFVAR || d1.sym->type == UNDEFVEC)
  1183.             Ft_matherror("%s: Unassigned vector.", d1.sym->name, 0);
  1184.         else
  1185.             Ft_matherror("%s: Illegal element assignment.", d1.sym->name, 0);
  1186.     }
  1187.     d2 = Ft_pop();
  1188.     d3 = Ft_pop();
  1189.     index = (int)d3.val;
  1190.     if (index < 1 || index > d1.sym->size.val) {
  1191.         Ft_matherror("%s: Index %d out of range.", d1.sym->name, index);
  1192.     }
  1193.     d2.val = (d1.sym->u.vec[index] *= d2.val);
  1194.     Ft_push(d2);
  1195. }
  1196.  
  1197. Code Ft_edivassign(void)
  1198. {
  1199.     Datum d1, d2, d3;
  1200.     int index;
  1201.     extern int Ft_Check;
  1202.  
  1203.     CODE("edivassign");
  1204.     d1 = Ft_pop();
  1205.     if (d1.sym->type != VEC && d1.sym->type != PARAM) {
  1206.         if (d1.sym->type == UNDEFVAR || d1.sym->type == UNDEFVEC)
  1207.             Ft_matherror("%s: Unassigned vector.", d1.sym->name, 0);
  1208.         else
  1209.             Ft_matherror("%s: Illegal element assignment.", d1.sym->name, 0);
  1210.     }
  1211.     d2 = Ft_pop();
  1212.     if (d2.val == 0.0 && Ft_Check & INF_CHK) {
  1213.         Ft_matherror("%s: Division by zero.", d1.sym->name, 0);
  1214.     }
  1215.     d3 = Ft_pop();
  1216.     index = (int)d3.val;
  1217.     if (index < 1 || index > d1.sym->size.val) {
  1218.         Ft_matherror("%s: Index %d out of range.", d1.sym->name, index);
  1219.     }
  1220.     d2.val = (d1.sym->u.vec[index] /= d2.val);
  1221.     Ft_push(d2);
  1222. }
  1223.  
  1224. Code Ft_esubassign(void)
  1225. {
  1226.     Datum d1, d2, d3;
  1227.     int index;
  1228.  
  1229.     CODE("esubassign");
  1230.     d1 = Ft_pop();
  1231.     if (d1.sym->type != VEC && d1.sym->type != PARAM) {
  1232.         if (d1.sym->type == UNDEFVAR || d1.sym->type == UNDEFVEC)
  1233.             Ft_matherror("%s: Unassigned vector.", d1.sym->name, 0);
  1234.         else
  1235.             Ft_matherror("%s: Illegal element assignment.", d1.sym->name, 0);
  1236.     }
  1237.     d2 = Ft_pop();
  1238.     d3 = Ft_pop();
  1239.     index = (int)d3.val;
  1240.     if (index < 1 || index > d1.sym->size.val) {
  1241.         Ft_matherror("%s: Index %d out of range.", d1.sym->name, index);
  1242.     }
  1243.     d2.val = (d1.sym->u.vec[index] -= d2.val);
  1244.     Ft_push(d2);
  1245. }
  1246.  
  1247. Code Ft_breakit(void)
  1248. {
  1249.     CODE("breakit");
  1250.     Break = 1;
  1251. }
  1252.  
  1253. Code Ft_chkfunc(int type, Symbol *sp)
  1254. {
  1255.     if (sp->type == UNDEFVAR || sp->type == FUNCSYM || sp->type == PROCSYM) {
  1256.         sp->type = type;
  1257.     }
  1258.     else {
  1259.         Ft_matherror("%s: Symbol already defined and protected.", sp->name, 0);
  1260.     }
  1261. }
  1262.  
  1263. Code Ft_define(Symbol *sp)
  1264. {
  1265.     sp->u.defn = Ft_Progbase;
  1266.     Ft_Progbase = Ft_Progp;
  1267. }
  1268.  
  1269. Code Ft_call(void)
  1270. {
  1271.     Symbol *sp = (Symbol *)pc[0];
  1272.     Inst *pp;
  1273.  
  1274.     CODE("call");
  1275.     CODE(sp->name);
  1276.     if (frp++ >= &frame[NFRAME-1]) {
  1277.          frp--;
  1278.          Ft_matherror("%s: Call too deeply nested.", sp->name, 0);
  1279.     }
  1280.     frp->sp = sp;
  1281.     frp->nargs = (int)pc[1];
  1282.     PNUM(frp->nargs);
  1283.     frp->retpc = pc+2; /* return at second next address */
  1284.     frp->argn = stackp - 1;
  1285.     pp = checkargs(sp->u.defn, frp);
  1286.     Ft_execute(pp);
  1287.     Returning = 0;
  1288. }
  1289.  
  1290. Code Ft_boost(void)   /* a lot of self-consistency implied... */
  1291. {
  1292.     CODE("boost");
  1293.     PNUM((int)pc[0]);
  1294.     frp->nargs += (int) *pc++;
  1295.     frp->argn = stackp-1;
  1296. }
  1297.  
  1298. Code Ft_restore(void)
  1299. {
  1300.     CODE("restore");
  1301.     PNUM((int)pc[0]);
  1302.     cleanfrp((int)*pc++);
  1303. }
  1304.  
  1305. void Ft_cleanframe(void)
  1306. {
  1307.     while (frp != frame) {
  1308.         cleanfrp(ALL);
  1309.         frp--;
  1310.     }
  1311. }
  1312.  
  1313. static void cleanfrp(int num)
  1314. {
  1315.     Symbol *sp;
  1316.  
  1317.     if (num == ALL) {
  1318.         num = frp->nargs;
  1319.     }
  1320.     else if (num > frp->nargs) {
  1321.         Ft_matherror("Impossible condition in clean frame.", NULL, 0);
  1322.     }
  1323.     /******
  1324.     if (dp + 1 != stackp) {
  1325.         fprintf(stderr, "Inconsistent difference: %d\n", stackp-1-dp);
  1326.     }
  1327.     *******/
  1328.     while (num--) {
  1329.         frp->nargs--;
  1330.         frp->argn -= 2;
  1331.         switch ((int)frp->argn[2].val) {
  1332.         case NUMBER:
  1333.         case VEC:
  1334.         case PARAM:
  1335.         case STRVAR:
  1336.             break;
  1337.         case AUTOVEC:
  1338.             sp = (Symbol *) (int) frp->argn[1].val;
  1339.             free(sp->name);
  1340.             Ft_free_dvector(sp->u.vec, 1, sp->size.val);
  1341.             free((char *)sp);
  1342.             break;
  1343.         case AUTOSTRVAR:
  1344.             sp = (Symbol *) (int) frp->argn[1].val;
  1345.             free(sp->name);
  1346.             free(sp->u.str);
  1347.             free((char *)sp);
  1348.             break;
  1349.         default:
  1350.             Ft_matherror("Impossible case in cleanfrp.", NULL, 0);
  1351.         }
  1352.     }
  1353. }    
  1354.  
  1355. Code Ft_pushnull(void)
  1356. {
  1357.     Datum d;
  1358.  
  1359.     CODE("pushnull");
  1360.     d.val = 0.0;
  1361.     Ft_push(d);
  1362. }
  1363.  
  1364. static void ret(void)
  1365. {
  1366.     CODE("ret");
  1367.  
  1368.     cleanfrp(ALL); /* clean stack of all auto variables, arguments...*/
  1369.     pc = (Inst *)frp->retpc;
  1370.     stackp = frp->argn + 1;
  1371.     frp--;
  1372.     Returning = 1;
  1373. }
  1374.  
  1375. Code Ft_funcret(void)
  1376. {
  1377.     Datum d;
  1378.  
  1379.     CODE("funcret");
  1380.     if (frp->sp->type == PROCSYM) {
  1381.          Ft_matherror("%s: Procedure returning value!", frp->sp->name, 0);
  1382.     }
  1383.     d = Ft_pop();
  1384.     ret();
  1385.     Ft_push(d);
  1386. }
  1387.  
  1388. Code Ft_procret(void)
  1389. {
  1390.     CODE("procret");
  1391.     if (frp->sp->type == FUNCSYM) {
  1392.         Ft_matherror("%s: Function not returning value!", frp->sp->name, 0);
  1393.     }
  1394.     ret();
  1395. }
  1396.  
  1397. static double *getarg(void)
  1398. {
  1399.     int which;
  1400.   
  1401.     CODE("getarg");
  1402.     which = (int)*pc++;
  1403.     PNUM(which);
  1404.     if (which > frp->nargs) {
  1405.         Ft_matherror("%s: Not enough arguments.", frp->sp->name, 0);
  1406.     }
  1407.     return(&frp->argn[2*(which - frp->nargs) - 1].val);
  1408. }
  1409.  
  1410. Code Ft_argpush(void)
  1411. {
  1412.     Datum d;
  1413.  
  1414.     CODE("argpush");
  1415.     d.val = *getarg();
  1416.     Ft_push(d);
  1417. }
  1418.  
  1419. Code Ft_predargpush(void)
  1420. {
  1421.     Datum d;
  1422.  
  1423.     CODE("predargpush");
  1424.     d.val = (*getarg() -= 1.0);
  1425.     Ft_push(d);
  1426. }
  1427.  
  1428. Code Ft_preiargpush(void)
  1429. {
  1430.     Datum d;
  1431.  
  1432.     CODE("preiargpush");
  1433.     d.val = (*getarg() += 1.0);
  1434.     Ft_push(d);
  1435. }
  1436.  
  1437. Code Ft_postiargpush(void)
  1438. {
  1439.     Datum d;
  1440.     double *dp;
  1441.  
  1442.     CODE("postiargpush");
  1443.     dp = getarg();
  1444.     d.val = *dp;
  1445.     *dp += 1.0;
  1446.     Ft_push(d);
  1447. }
  1448.  
  1449. Code Ft_postdargpush(void)
  1450. {
  1451.     Datum d;
  1452.     double *dp;
  1453.  
  1454.     CODE("postiargpush");
  1455.     dp = getarg();
  1456.     d.val = *dp;
  1457.     *dp -= 1.0;
  1458.     Ft_push(d);
  1459. }
  1460.  
  1461. Code Ft_argassign(void)
  1462. {
  1463.     Datum d;
  1464.  
  1465.     CODE("argassign");
  1466.     d = Ft_pop();
  1467.     Ft_push(d);
  1468.     *getarg() = d.val;
  1469. }
  1470.  
  1471. Code Ft_argaddassign(void)
  1472. {
  1473.     Datum d;
  1474.  
  1475.     CODE("argaddassign");
  1476.     d = Ft_pop();
  1477.     d.val = (*getarg() += d.val);
  1478.     Ft_push(d);
  1479. }
  1480.  
  1481. Code Ft_argmulassign(void)
  1482. {
  1483.     Datum d;
  1484.  
  1485.     CODE("argmulassign");
  1486.     d = Ft_pop();
  1487.     d.val = (*getarg() *= d.val);
  1488.     Ft_push(d);
  1489. }
  1490.  
  1491. Code Ft_argsubassign(void)
  1492. {
  1493.     Datum d;
  1494.  
  1495.     CODE("argsubassign");
  1496.     d = Ft_pop();
  1497.     d.val = (*getarg() -= d.val);
  1498.     Ft_push(d);
  1499. }
  1500.  
  1501. Code Ft_argdivassign(void)
  1502. {
  1503.     Datum d;
  1504.     extern int Ft_Check;
  1505.  
  1506.     CODE("argdivassign");
  1507.     d = Ft_pop();
  1508.     if (d.val == 0.0 && Ft_Check & INF_CHK) {
  1509.         Ft_matherror("Division by zero.", NULL, 0);
  1510.     }
  1511.     d.val = (*getarg() /= d.val);
  1512.     Ft_push(d);
  1513. }
  1514.  
  1515. Code Ft_pushexprtype(void)
  1516. {
  1517.     Datum d;
  1518.  
  1519.     CODE("pushexprtype");
  1520.     d.val = NUMBER;
  1521.     Ft_push(d);
  1522. }
  1523.  
  1524. Code Ft_pushvectype(void)
  1525. {
  1526.     Datum d;
  1527.  
  1528.     CODE("pushvectype");
  1529.     d.val = VEC;
  1530.     Ft_push(d);
  1531. }
  1532.  
  1533. Code Ft_pushstrtype(void)
  1534. {
  1535.     Datum d;
  1536.  
  1537.     CODE("pushstrtype");
  1538.     d.val = STRVAR;
  1539.     Ft_push(d);
  1540. }
  1541.  
  1542. Code Ft_pushpartype(void)
  1543. {
  1544.     Datum d;
  1545.  
  1546.     CODE("pushpartype");
  1547.     d.val = PARAM;
  1548.     Ft_push(d);
  1549. }
  1550.  
  1551. Code Ft_pushavectype(void)
  1552. {
  1553.     Datum d;
  1554.  
  1555.     CODE("pushavectype");
  1556.     d.val = AUTOVEC;
  1557.     Ft_push(d);
  1558. }
  1559.  
  1560. Code Ft_pushastrtype(void)
  1561. {
  1562.     Datum d;
  1563.  
  1564.     CODE("pushastrtype");
  1565.     d.val = AUTOSTRVAR;
  1566.     Ft_push(d);
  1567. }
  1568.  
  1569. void Ft_defnonly(int type, char *string)
  1570. {
  1571.     switch(type) {
  1572.         case WHILE:
  1573.             if (Ft_Inbrace) return;
  1574.             Ft_matherror("`%s' used outside for or while loop.", string, 0);
  1575.             break;
  1576.         case FUNC:
  1577.             if (Ft_Indef) return;
  1578.             Ft_matherror("`%s' used outside function.", string, 0);
  1579.             break;
  1580.         case PROC:
  1581.             if (Ft_Indef) return;
  1582.             Ft_matherror("`%s' used outside procedure.", string, 0);
  1583.             break;
  1584.         default:
  1585.             Ft_matherror("Strange condition in chkfunc().", NULL, 0);
  1586.             break;
  1587.     }
  1588. }
  1589.  
  1590. Code Ft_argvarpush(void)
  1591. {
  1592.     Datum d;
  1593.     int which;
  1594.  
  1595.     CODE("argvarpush");
  1596.     which = (int)*pc++;
  1597.     d.sym = frp->argn[2*(which - frp->nargs) - 1].sym;
  1598.     CODE(d.sym->name);
  1599.     Ft_push(d);
  1600. }
  1601.  
  1602. Code Ft_strmake(void)
  1603. {
  1604.     Datum d;
  1605.     
  1606.     CODE("strmake");
  1607.     d.sym = Ft_geninstall("auto String", UNDEFSTRVAR, 0);
  1608.     Ft_push(d);
  1609. }
  1610.  
  1611. Code Ft_vecmake(void)
  1612. {
  1613.     Datum d;
  1614.     extern int Ft_Samples;
  1615.     
  1616.     CODE("vecmake");
  1617.     d.sym = Ft_geninstall("auto VEC", UNDEFVEC, Ft_Samples);
  1618.     Ft_push(d);
  1619. }
  1620.  
  1621. static Inst *checkargs(Inst *start, Frame *frpp)
  1622. {
  1623.     Datum *dp;
  1624.     int i, type, num;
  1625.  
  1626.     num = 0;
  1627.     while (start[num] != STOP) {
  1628.         num++;
  1629.     }
  1630.     if (num != frpp->nargs) {
  1631.         Ft_matherror("%s(): Argument number mismatch (%d required).",
  1632.         frpp->sp->name, num);
  1633.     }
  1634.     dp  = frpp->argn;  /* park it on the last type */
  1635.     start += num-1; /* park it on the last argument type */
  1636.     for (i=1-num; i<= 0; i++) {
  1637.         type = (int) dp[2*i].val;
  1638.         if (type != (int)start[i]) {
  1639.             Ft_matherror("%s(): Argument %d mismatch.", frpp->sp->name, (1-i));
  1640.         }
  1641.     }
  1642.     return(start+2);  /* skip the STOP */
  1643. }
  1644.  
  1645. void Ft_matherror(char *s1, char *s2, int lino)
  1646. {
  1647.     extern char Ft_Puffer[];
  1648.  
  1649.     fputs("Math error: ", stderr);
  1650.     fprintf(stderr, s1, s2, lino);
  1651.     fputc('\n', stderr);
  1652.     if (Index != ERRR)
  1653.         fprintf(stderr, "Error occurred at vector element %d.\n", Index);
  1654.     fprintf(stderr, "Command line: %s", Ft_Puffer);
  1655.     Ft_catcher(ERRR);
  1656. }
  1657.  
  1658. int Ft_showtable(void)
  1659. {
  1660.     FILE *fp;
  1661.     Symbol *sp, *Ft_Symlist(void);
  1662.     extern int Ft_Interact;
  1663.     extern char Ft_Pager[];
  1664.     extern FILE *popen(const char *, const char *);
  1665.     extern Datum *stack, *stackp;
  1666.     extern Frame *frame, *frp;
  1667.     extern Inst *prog;
  1668.  
  1669.     if (Ft_Interact && *Ft_Pager) {
  1670.         if ((fp = popen(Ft_Pager, "w")) == (FILE *)NULL)  {
  1671.             fprintf(stderr, "Could not open pager %s.\n", Ft_Pager);
  1672.             fp = stdout;
  1673.         }
  1674.     }
  1675.     else {
  1676.         fp = stdout;
  1677.     }
  1678.  
  1679.     fprintf(fp, "%12s%35s%10s\n", "Name", "Type", "Size");
  1680.     for (sp = Ft_Symlist(); sp != (Symbol *)0; sp = sp->next) {
  1681.         switch (sp->type) {
  1682.             case VEC:
  1683.                 fprintf(fp, "%12s%35s%10d\n",
  1684.                 sp->name, "VEC", sp->size.val);
  1685.                 break;
  1686.             case PARAM:
  1687.                 fprintf(fp, "%12s%35s%10d\n",
  1688.                 sp->name, "PAR", sp->size.val);
  1689.                 break;
  1690.             case BLTINSTRCONST:
  1691.                 fprintf(fp, "%12s%35s%10d\n",
  1692.                 sp->name, "Bltin Str Constant", strlen(sp->u.str));
  1693.                 break;
  1694.             case STRCONST:
  1695.                 fprintf(fp, "%12s%35s%10d\n",
  1696.                 sp->name, "Str Constant", strlen(sp->u.str));
  1697.                 break;
  1698.             case BLTINCONST:
  1699.                 fprintf(fp, "%12s%35s%10s\n",
  1700.                 sp->name, "bltin constant", "1");
  1701.                 break;
  1702.             case CONST:
  1703.                 fprintf(fp, "%12s%35s%10s\n",
  1704.                 sp->name, "constant", "1");
  1705.                 break;
  1706.             case BLTINVAR:
  1707.                 fprintf(fp, "%12s%35s%10s\n",
  1708.                 sp->name, "bltin variable", "1");
  1709.                 break;
  1710.             case VAR:
  1711.                 fprintf(fp, "%12s%35s%10s\n",
  1712.                 sp->name, "variable", "1");
  1713.                 break;
  1714.             case BLTINSTRVAR:
  1715.                 fprintf(fp, "%12s%35s%10d\n",
  1716.                 sp->name, "Bltin Str Variable", sp->size.val);
  1717.                 break;
  1718.             case STRVAR:
  1719.                 fprintf(fp, "%12s%35s%10d\n",
  1720.                 sp->name, "Str Variable", sp->size.val);
  1721.                 break;
  1722.             case BLTIN0STR:
  1723.                 fprintf(fp, "%12s%35s%10s\n",
  1724.                 sp->name, "Str Function(void)", "1");
  1725.                 break;
  1726.             case BLTIN1STR:
  1727.                 fprintf(fp, "%12s%35s%10s\n",
  1728.                 sp->name, "Str Function(Str)", "1");
  1729.                 break;
  1730.             case BLTIN2STR:
  1731.                 fprintf(fp, "%12s%35s%10s\n",
  1732.                 sp->name, "Str Function(Str, Str)", "1");
  1733.                 break;
  1734.             case BLTIN0:
  1735.                 fprintf(fp, "%12s%35s%10s\n",
  1736.                 sp->name, "function(void)", "1");
  1737.                 break;
  1738.             case BLTIN1:
  1739.                 fprintf(fp, "%12s%35s%10s\n",
  1740.                 sp->name, "function(expr)", "1");
  1741.                 break;
  1742.             case BLTIN2:
  1743.                 fprintf(fp, "%12s%35s%10s\n",
  1744.                 sp->name, "function(expr, expr)", "1");
  1745.                 break;
  1746.             case STRBLTIN2:
  1747.                 fprintf(fp, "%12s%35s%10s\n",
  1748.                 sp->name, "function(Str, Str)", "1");
  1749.                 break;
  1750.             case EFUNCSYM:
  1751.                 fprintf(fp, "%12s%35s%10s\n",
  1752.                 sp->name, makename(sp), "1");
  1753.                 break;
  1754.             case FUNCSYM:
  1755.                 fprintf(fp, "%12s%35s%10s  from % 4d\n",
  1756.                 sp->name, makename(sp), "1", sp->u.defn -prog);
  1757.                 break;
  1758.             case EPROCSYM:
  1759.                 fprintf(fp, "%12s%35s%10s\n",
  1760.                 sp->name, makename(sp), "1");
  1761.                 break;
  1762.             case PROCSYM:
  1763.                 fprintf(fp, "%12s%35s%10s  from % 4d\n",
  1764.                 sp->name, makename(sp), "1", sp->u.defn -prog);
  1765.                 break;
  1766.             case UNDEFSTRVAR:
  1767.                 fprintf(fp, "%12s%35s%10s\n",
  1768.                 sp->name, "Unassigned Str Variable", "0");
  1769.                 break;
  1770.             case UNDEFVAR:
  1771.                 fprintf(fp, "%12s%35s%10s\n",
  1772.                 sp->name, "unassigned variable", "1");
  1773.                 break;
  1774.             case UNDEFVEC:
  1775.                 fprintf(fp, "%12s%35s%10d\n",
  1776.                 sp->name, "UNASSIGNED VEC", sp->size.val);
  1777.                 break;
  1778.             default:
  1779.                 /*** Why print keywords?
  1780.                 fprintf(fp, "%12s%35s%10d\n", "Keyword", sp->size.val);
  1781.                 ***********/
  1782.                 break;
  1783.         }
  1784.     }
  1785.     fprintf(fp,
  1786.     "\nactual: Stack: % 4d/%d,\tMachine: % 4d/%d,\tFrame: % 4d/%d\n",
  1787.     (stackp-stack), NSTACK, (Ft_Progp-prog), NPROG, (frp-frame), NFRAME);
  1788.     Ft_initcode();
  1789.     fprintf(fp,
  1790.     "reset:  Stack: % 4d/%d,\tMachine: % 4d/%d,\tFrame: % 4d/%d\n",
  1791.     (stackp-stack), NSTACK, (Ft_Progp-prog), NPROG, (frp-frame), NFRAME);
  1792.     if (fp != stdout) pclose(fp);
  1793.     return(0);
  1794. }
  1795.  
  1796. static char *makename(Symbol *sp)
  1797. {
  1798.     char *lp;
  1799.     static char arglist[256];
  1800.     int ext = 0;
  1801.  
  1802.     arglist[0] = '\0';
  1803.     switch (sp->type) {
  1804.         case EFUNCSYM:
  1805.             strcpy(arglist, " ext.");
  1806.             ext = 1;
  1807.         case FUNCSYM:
  1808.             strcat(arglist, " function(");
  1809.             break;
  1810.         case EPROCSYM:
  1811.             strcpy(arglist, " ext.");
  1812.             ext = 1;
  1813.         case PROCSYM:
  1814.             strcat(arglist, " procedure(");
  1815.             break;
  1816.         default:
  1817.             Ft_matherror("%s: Unknown function type %d.", "makename",
  1818.             sp->type); 
  1819.             break;
  1820.     }
  1821.     if (ext) {
  1822.         char *cp;
  1823.  
  1824.         cp = sp->size.vals;
  1825.         while (*cp)   /* go at the end */
  1826.             cp++;
  1827.     
  1828.         while (--cp >= sp->size.vals) {  /* come back */
  1829.             switch (*cp) {
  1830.                 case PROTO_VEC:
  1831.                     strcat(arglist, "VEC, ");
  1832.                     break;
  1833.                 case PROTO_VAL:
  1834.                     strcat(arglist, "expr, ");
  1835.                     break;
  1836.                 case PROTO_PAR:
  1837.                     strcat(arglist, "PAR, ");
  1838.                     break;
  1839.                 case PROTO_STR:
  1840.                     strcat(arglist, "Str, ");
  1841.                     break;
  1842.                 default:
  1843.                     Ft_matherror("%s: Unknown case %d.", "makename", *cp); 
  1844.                     break;
  1845.             }
  1846.         }
  1847.     }
  1848.     else {
  1849.         Inst *pp = sp->u.defn;
  1850.  
  1851.         while (*pp != STOP) {
  1852.             switch ((int) *pp) {
  1853.                 case VEC:
  1854.                     strcat(arglist, "VEC, ");
  1855.                     break;
  1856.                 case NUMBER:
  1857.                     strcat(arglist, "expr, ");
  1858.                     break;
  1859.                 case PARAM:
  1860.                     strcat(arglist, "PAR, ");
  1861.                     break;
  1862.                 case STRVAR:
  1863.                     strcat(arglist, "Str, ");
  1864.                     break;
  1865.                 default:
  1866.                     Ft_matherror("%s: Unknown case %d.", "makename", (int)*pp); 
  1867.                     break;
  1868.             }
  1869.             pp++;
  1870.         }
  1871.     }
  1872.     lp = arglist + strlen(arglist) - 2;
  1873.     *lp++ = ')';
  1874.     *lp = '\0';
  1875.  
  1876.     return(arglist);
  1877. }
  1878.  
  1879.